home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 22
/
Cream of the Crop 22.iso
/
os2
/
ftree11a.zip
/
DESCENDS.FTX
< prev
next >
Wrap
Text File
|
1996-10-30
|
4KB
|
131 lines
/*
Family Tree Rexx Script FTX
Copyright (C) 1996 by <Peter Gervai>
Please send comments to
Grin at 2:370/15@fidonet or grin@lifeforce.fido.hu
<
English: Prints descendants of the actual person in hierarchical fashion. :English
Deutsch: Gibt die Nachfahren der aktuellen Person in hierarchischer Weise aus. :Deutsch
Nederlands:Prints descendants of the actual person in hierarchical fashion. :Nederlands
Francais: Imprime de manière hiérarchique, la descendance de la personne
sélectionnée. :Francais
>
Long name is <
English: List Descendants :English
Deutsch: Auflisten der Nachfahren :Deutsch
Nederlands: List Descendants :Nederlands
Francais: Imprime la descendance :Francais
>
*/
call InitLanguage
/*
* Global variables (for EXPOSE in procedures)
*/
globals = 'cr msg.'
cr = '0a'x
/*
* start
*/
title = msg.Header.LANG getName()',' getFirstName()
say title
say copies('=',length(title))
call DoStack('PP')
call DEmitPerson 1
say msg.Finish.LANG
exit;
/*
* recursive function
*/
DEmitPerson: procedure expose (globals); parse arg level
/* pull actual person */
if DoStack('pP')=0 then perror(msg.Error.LANG)
de.husband = copies(' ',level) || getName()',' getFirstName()'('getBirthDate()'/'getDeathDate()')'
call charout ,de.husband
de.count = 1
/* check families */
res = SelectFamily(de.count)
do while res\=0
/* print wife */
call DoStack('PP')
res = SelectPerson('p')
if de.count=1 then
call charout ,' +' getName()',' getFirstName()'('getBirthDate()'/'getDeathDate()')'cr
else
call charout ,de.husband '+' getName()',' getFirstName()'('getBirthDate()'/'getDeathDate()')'cr
call DoStack('pP')
/* examine children */
call DoStack('PP') /* original person */
de.childcount = 1
res = SelectPerson(de.childcount)
do while res\=0
/* print children's tree */
call DoStack('PF') /* save family because SelectPerson(<count>) needs it! */
call DoStack('PP') /* push child for recursion (routine pops it) */
call DEmitPerson level+2 /* print child's tree (indent2) */
de.childcount = de.childcount + 1
call DoStack('pP') /* pop original person... */
call DoStack('PP') /* ...and push again... */
call DoStack('pF') /* original family */
res = SelectPerson(de.childcount) /* ...just for get his next child */
end
call DoStack('pP') /* original person */
de.count = de.count + 1 /* next family */
res = SelectFamily(de.count)
end
if de.count=1 then call charout ,cr
return
/******************************************************************
*
* Language init
*
*/
InitLanguage:
/* Calculate Language Index */
lang='E' /* Default -> [E]nglish */
IF getLanguage()='Deutsch' THEN /* Deutsch -> [G]erman */
lang='G'
IF getLanguage()='Nederlands' THEN /* Nederlands -> [D]utch */
lang='D'
IF getLanguage()='Francais' THEN /* Francais -> [F]rench */
lang='F'
/* [E]nglish Messages */
msg.Header.E = 'Descendants of'
msg.Finish.E = '===Finished==='
msg.Error.E = 'SCRIPT ERROR: Empty Stack!'
/* [G]erman Messages */
msg.Header.G = 'Nachfahren von'
msg.Finish.G = '===Beendet==='
msg.Error.G = 'SCRIPT FEHLER: Leerer Stack!'
/* [D]utch Messages */
msg.Header.E = 'Descendants of'
msg.Finish.E = '===Finished==='
msg.Error.E = 'SCRIPT ERROR: Empty Stack!'
/* [F]rench Messages */
msg.Header.F = "Descendants de"
msg.Finish.F = "===Terminé==="
msg.Error.F = "ERREUR SCRIPT: Pile Vide!"
/* Done */
RETURN